(in-package :io)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Reader programming

(defparameter *io-readtable* (copy-readtable))

(defun read-model-object (stream char)
  (declare (ignore char))
  (apply #'make-instance (read-delimited-list #\] stream t)))

(set-macro-character #\[ #'read-model-object nil *io-readtable*)
(set-syntax-from-char #\] #\) *io-readtable*)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Printer programming

(defgeneric save-info (object)
  (:method-combination append :most-specific-last))

;;; should really use *print-readably*
(defparameter *print-for-file-io* nil)

(defun print-model-object (obj stream)
  (pprint-logical-block (stream nil :prefix "[" :suffix "]")
			(format stream "~s ~2i" (class-name (class-of obj)))
			(loop for info in (save-info obj)
			      do (format stream
					 "~_~s ~W "
					 (car info)
					 (funcall (cadr info) obj)))))

(defmacro define-save-info (type &body save-info)
  `(progn
     (defmethod print-object :around ((obj ,type) stream)
       (if *print-for-file-io*
           (print-model-object obj stream)
           (call-next-method)))

     (defmethod save-info append ((obj ,type))
       ',save-info)))

(defun read-model-from-stream (stream allowed-version-names)
  (let ((version (read-line stream)))
    (assert (member version allowed-version-names :test #'string=))
    (if (member version allowed-version-names :test #'string=)
	(let ((*read-eval* nil)
	      (*readtable* *io-readtable*))
	  (read stream))
	'unknown-file-version)))

(defun read-model (filename allowed-version-names)
  (assert (probe-file filename) () 'file-does-not-exist)
  (with-open-file (stream filename :direction :input :if-does-not-exist nil)
    (if stream
	(read-model-from-stream stream allowed-version-names)
	'file-does-not-exist)))

(defun write-model-to-stream (stream version-name object)
  (let ((*print-circle* t)
	(*print-for-file-io* t)
	(*package* (find-package :keyword)))
    (format stream "~a~%" version-name)
    (pprint object stream)
    (terpri stream)
    (finish-output stream)))

(defun write-model (filename version-name object)
  (with-open-file (stream filename
                          :direction :output
                          :if-exists :supersede
                          :if-does-not-exist :create)
    (when stream
      (write-model-to-stream stream version-name object))))

(defun copy-model (object version-name)
  (with-input-from-string
      (in
       (with-output-to-string (out)
	 (write-model-to-stream out version-name object)))
    (read-model-from-stream in (list version-name))))
